home *** CD-ROM | disk | FTP | other *** search
/ Gekkan Dennou Club 147 / Gekkan Dennou Club - 2000.8 Vol. 147 (Japan).7z / Gekkan Dennou Club - 2000.8 Vol. 147 (Japan) (Track 1).bin / docs / perl / monitor.pm < prev    next >
Text File  |  2000-06-25  |  4KB  |  183 lines
  1. #
  2. # Monitor.pm : タイを使った変数の監視
  3. #
  4. #
  5. package Monitor;
  6. use Exporter;
  7. @ISA = (Exporter);
  8. @EXPORT_OK = ('monitor', 'unmonitor');
  9.  
  10. # 変数を監視する
  11. sub monitor {
  12.     my ($rvar, $name) = @_;
  13.     my $type = ref( $rvar );     # 型のチェック
  14.     if( $type eq 'SCALAR' ){
  15.     tie $$rvar, 'MonScalar', $name, $$rvar;
  16.     } elsif( $type eq 'ARRAY' ){
  17.     tie @$rvar, 'MonArray', $name, $rvar;
  18.     } elsif( $type eq 'HASH' ){
  19.     tie %$rvar, 'MonHash', $name, $rvar;
  20.     } else {
  21.     print STDERR "リファレンスが必要です\n";
  22.     }
  23. }
  24.  
  25. # 変数の監視を止める
  26. sub unmonitor {
  27.     my $rvar = shift;
  28.     my $type = ref( $rvar );     # 型のチェック
  29.     if( $type eq 'SCALAR' ){
  30.     MonScalar->unmonitor( $rvar );
  31.     } elsif( $type eq 'ARRAY' ){
  32.     MonArray->unmonitor( $rvar );
  33.     } elsif( $type eq 'HASH' ){
  34.     MonHash->unmonitor( $rvar );
  35.     } else {
  36.     print STDERR "リファレンスが必要です\n";
  37.     }
  38. }
  39.  
  40. # スカラーの監視
  41. package MonScalar;
  42.  
  43. sub TIESCALAR {
  44.     my ($pkg, $name, $value) = @_;
  45.     my $obj = { name => $name, value => $value };
  46.     bless $obj, $pkg;
  47.     $obj;
  48. }
  49.  
  50. sub FETCH {
  51.     my $obj = shift;
  52.     print 'Read : $', $obj->{'name'}, " -> $obj->{'value'}\n";
  53.     $obj->{'value'};
  54. }
  55.  
  56. sub STORE {
  57.     my ($obj, $new_value) = @_;
  58.     print 'Write : $', $obj->{'name'}," <- $new_value\n";
  59.     $obj->{'value'} = $new_value;
  60. }
  61.  
  62. sub DESTROY {
  63.     my $obj = shift;
  64.     if( $obj->{'name'} ne '__UNMONITOR__' ){
  65.     print 'DESTORY $', "$obj->{'name'}\n";
  66.     }
  67. }
  68.  
  69.  
  70. sub unmonitor {
  71.     my ($pkg, $rvar) = @_;
  72.     my $last_value;
  73.     {
  74.     my $obj = tied $$rvar;
  75.     $last_value = $obj->{'value'};
  76.     $obj->{'name'} = '__UNMONITOR__'
  77.     }
  78.     untie $$rvar;
  79.     $$rvar = $last_value;
  80. }
  81.  
  82.  
  83. # 配列の監視
  84. package MonArray;
  85.  
  86. sub TIEARRAY {
  87.     my ($pkg, $name, $ra) = @_;
  88.     my $obj = {
  89.     name => $name, array => [@$ra],
  90.     };
  91.     bless $obj, $pkg;
  92.     $obj;
  93. }
  94.  
  95. sub FETCH {
  96.     my ($obj, $index) = @_;
  97.     my $value = $obj->{'array'}->[$index];
  98.     print 'Read : $',$obj->{'name'}, "[$index] -> $value\n";
  99.     $value;
  100. }
  101.  
  102. sub STORE {
  103.     my ($obj, $index, $new_value) = @_;
  104.     print 'Write : $',$obj->{'name'}, "[$index] <- $new_value\n";
  105.     $obj->{'array'}->[$index] = $new_value;
  106. }
  107.  
  108. sub DESTROY {
  109.     my $obj = shift;
  110.     if( $obj->{'name'} ne '__UNMONITOR__' ){
  111.     print 'DESTORY @', "$obj->{'name'}\n";
  112.     }
  113. }
  114.  
  115. sub unmonitor {
  116.     my ($pkg, $rvar) = @_;
  117.     my $last_array;
  118.     {
  119.     my $obj = tied @$rvar;
  120.     $last_array = $obj->{'array'};
  121.     $obj->{'name'} = '__UNMONITOR__'
  122.     }
  123.     untie @$rvar;
  124.     @$rvar = @$last_array;
  125. }
  126.  
  127.  
  128. # ハッシュの監視
  129. package MonHash;
  130.  
  131. sub TIEHASH {
  132.     my ($pkg, $name, $rh) = @_;
  133.     my $obj = {
  134.     name => $name, hash => {%$rh},
  135.     };
  136.     bless $obj, $pkg;
  137.     $obj;
  138. }
  139.  
  140. sub FETCH {
  141.     my ($obj, $index) = @_;
  142.     my $value = $obj->{'hash'}->{$index};
  143.     print 'Read : $', $obj->{'name'}, "{$index} -> $value\n";
  144.     $value;
  145. }
  146.  
  147. sub STORE {
  148.     my ($obj, $index, $new_value) = @_;
  149.     print 'Write : $', $obj->{'name'}, "{$index} <- $new_value\n";
  150.     $obj->{'hash'}->{$index} = $new_value;
  151. }
  152.  
  153. sub CLEAR {
  154.     my $obj = shift;
  155.     print 'Clear : %', "$obj->{'name'}\n";
  156.     $obj->{'hash'} = {};
  157. }
  158.  
  159. sub DESTROY {
  160.     my $obj = shift;
  161.     if( $obj->{'name'} ne '__UNMONITOR__' ){
  162.     print 'DESTORY %', "$obj->{'name'}\n";
  163.     }
  164. }
  165.  
  166. sub unmonitor {
  167.     my ($pkg, $rvar) = @_;
  168.     my $last_hash;
  169.     {
  170.     my $obj = tied %$rvar;
  171.     $last_hash = $obj->{'hash'};
  172.     $obj->{'name'} = '__UNMONITOR__'
  173.     }
  174.     untie %$rvar;
  175.     %$rvar = %$last_hash;
  176. }
  177.  
  178.  
  179. 1;
  180.     
  181. # end of file
  182.     
  183.